home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / modes.tcl < prev    next >
Encoding:
Text File  |  1999-01-15  |  16.6 KB  |  603 lines  |  [TEXT/ALFA]
  1. # (nowrap)
  2.  
  3. namespace eval mode {}
  4. namespace eval win {}
  5. namespace eval menu {}
  6.  
  7. # ◊◊◊◊ Declare Alpha packages ◊◊◊◊ #
  8.  
  9. proc alpha::feature {name version modes {initialise ""} {activate ""} {deactivate ""} args} {
  10.     global alpha::rebuilding
  11.     if {!${alpha::rebuilding}} {return}
  12.     global index::feature rebuild_cmd_count
  13.     if {[string trim "$initialise$activate$deactivate"] == ""} {
  14.     set index::feature($name) [list $version $modes -1]
  15.     } else {
  16.     set index::feature($name) [list $version $modes 0 $initialise $activate $deactivate]
  17.     }
  18.     
  19.     if {[llength $args]} {
  20.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  21.     return
  22.     }
  23.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  24.     return -code 11
  25.     }
  26. }
  27.  
  28. proc alpha::menu {name version modes {value ""} {initialise ""} {activate ""} {deactivate ""} args} {
  29.     global alpha::rebuilding
  30.     if {!${alpha::rebuilding}} {return}
  31.     if {[string index $modes 0] == "•"} {
  32.     # it's in the old format
  33.     set tmp $modes
  34.     set modes $value
  35.     if {$modes == "in_menu"} { set modes "global" }
  36.     set value $tmp
  37.     # perhaps there's a better way of collapsing these arguments
  38.     if {[llength $args]} {
  39.         set args [concat [list $activate $deactivate] $args]
  40.     } else {
  41.         if {$deactivate != ""} {
  42.         lappend activate $deactivate
  43.         set args $activate
  44.         } else {
  45.         set args $activate
  46.         }
  47.     }    
  48.     set activate "$name"
  49.     set deactivate ""
  50.     }
  51.     global index::feature rebuild_cmd_count
  52.     if {[info exists index::feature($name)]} {
  53.     eval lappend modes [lindex [set index::feature($name)] 1]
  54.     }
  55.     set index::feature($name) [list $version $modes 1 \
  56.       "ensureset $name $value\n$initialise" \
  57.       "$activate\ninsertMenu \$$name" \
  58.       "$deactivate\nremoveMenu \$$name"]
  59.     
  60.     if {[llength $args]} {
  61.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  62.     return
  63.     }
  64.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  65.     return -code 11
  66.     }        
  67. }
  68.  
  69. proc alpha::extension {name version {script ""} args} {
  70.     uplevel 1 [list alpha::feature $name $version "global-only" "" $script ""] $args
  71. }
  72.  
  73. proc alpha::mode {name version dummyProc {ext ""} {menus ""} {script ""} args} {
  74.     global alpha::rebuilding alpha::requirements
  75.     if {!${alpha::rebuilding}} {return}
  76.     namespace eval ::$name {}
  77.     global index::mode rebuild_cmd_count index::oldmode
  78.     set index::mode($name) [list $version $dummyProc [join $ext " "] $menus $script]
  79.     if {[info exists index::oldmode($name)]} {
  80.     if {[set omenus [lindex [set index::oldmode($name)] 3]] != $menus} {
  81.         global alpha::noMenusYet mode::features modifiedArrayElements
  82.         foreach m $menus {
  83.         # Store all version number requirements
  84.         if {[lindex $m 2] != ""} {
  85.             lappend alpha::requirements [list $name $m]
  86.         }
  87.         set mm [lindex $m 0]
  88.         if {([lsearch -exact $omenus $mm] == -1) \
  89.           && ([lsearch -glob $omenus "$mm *"] == -1)} {
  90.             # it's new
  91.             package::addRelevantMode $mm $name
  92.             if {[lindex $m 1] == 0} {continue}
  93.             if {[info exists alpha::noMenusYet]} {
  94.             # we added a feature 
  95.             hook::register startupHook "lunion mode::features($name) $mm"
  96.             } else {
  97.             lunion mode::features($name) $mm
  98.             lappend modifiedArrayElements [list $name mode::features]
  99.             }
  100.         }
  101.           
  102.         }
  103.         foreach om $omenus {
  104.         set omm [lindex $om 0]
  105.         if {([lsearch -exact $menus $omm] == -1) \
  106.           && ([lsearch -glob $menus "$omm *"] == -1)} {
  107.             # it has been removed from the default list
  108.             package::removeRelevantMode $omm $name
  109.             set mode::features($name) [lremove $mode::features($name) $omm]
  110.             lappend modifiedArrayElements [list $name mode::features]
  111.         }
  112.         }
  113.     }
  114.     }
  115.     if {[llength $args]} {
  116.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  117.     return
  118.     }
  119.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  120.     return -code 11
  121.     }        
  122. }
  123.  
  124. ## 
  125.  # -------------------------------------------------------------------------
  126.  # 
  127.  # "addMode" -- you probably won't call this proc yourself
  128.  # 
  129.  # -------------------------------------------------------------------------
  130.  ##
  131. proc addMode {m dummy suffs _features} {
  132.     global mode::features filepats dummyProc index::feature
  133.     namespace eval ::$m {}
  134.     if {[string length $dummy]} {set dummyProc($m) $dummy}
  135.     ensureset mode::features($m) $_features
  136.     foreach f $_features {
  137.     package::addRelevantMode $f $m
  138.     }
  139.     ensureset filepats($m) $suffs
  140. }
  141.  
  142. proc addMenu {name {val ""} {modes ""}} {
  143.     global menus index::feature
  144.     lunion menus $name
  145.     if {$val != ""} {
  146.     global $name
  147.     if {![info exists $name]} { set $name $val }
  148.     }
  149.     if {[info exists index::feature($name)]} {
  150.     eval lappend modes [lindex [set index::feature($name)] 1]
  151.     }
  152.     set index::feature($name) \
  153.       [list [list "mode" [lindex $modes 0]] $modes 1 "" "$name ; insertMenu \$$name" "removeMenu \$$name"]
  154. }
  155.  
  156.  
  157. # ◊◊◊◊ Procs Alpha calls directly ◊◊◊◊ #
  158. proc getModeValuesAlpha {} {
  159.     global showInvisibles
  160.     
  161.     getWinInfo blah
  162.     lappend m "Mac" [expr {$blah(platform) == "mac"}]
  163.     lappend m "UNIX" [expr {$blah(platform) == "unix"}]
  164.     lappend m "IBM" [expr {$blah(platform) == "ibm"}] {(-} 0
  165.     lappend m "MPW" [expr {$blah(state) == "mpw"}]
  166.     lappend m "Think" [expr {$blah(state) == "think"}]
  167.     lappend m "None" [expr {$blah(state) == "none"}] {(-} 0
  168.     lappend m "Read Only" $blah(read-only)
  169.     lappend m "Show Invisibles" $showInvisibles {(-} 0
  170.     lappend m "Tab Size" 0
  171.     return $m
  172. }
  173.  
  174.  
  175. proc setModeVarAlpha {var} {
  176.     global mode allFlags modeVars
  177.     global ${mode}modeVars
  178.     
  179.     set var [string tolower $var]
  180.     switch -- $var {
  181.         "unix"      -
  182.         "mac"       -
  183.         "ibm"       { setWinInfo platform $var ; setWinInfo dirty 1 }
  184.         "mpw"       -
  185.         "think"     -
  186.         "none"      { setWinInfo state $var }
  187.         "tab size"  {
  188.             getWinInfo arr
  189.             if {![catch {prompt "New tab size?" $arr(tabsize)} res]} {
  190.                 setWinInfo tabsize $res
  191.             }
  192.         }
  193.         "read only" { 
  194.             getWinInfo b
  195.             setWinInfo read-only [expr {-1 * ($b(read-only) - 1)}]}
  196.         "show invisibles" { 
  197.             global showInvisibles
  198.             set showInvisibles [expr {1 - $showInvisibles}]
  199.         }
  200.     }
  201.     return
  202. }
  203.  
  204. ## 
  205.  # -------------------------------------------------------------------------
  206.  # 
  207.  # "modes" --
  208.  # 
  209.  #  Called to get the list of modes for the modes popup
  210.  # -------------------------------------------------------------------------
  211.  ##
  212. proc modes {args} { 
  213.     global mode::features
  214.     return [lsort -ignore [array names mode::features]]
  215. }
  216.  
  217. # Called from alpha in response to the mode popup.
  218. proc newMode {mode} {
  219.     if {[package::helpOrDescribe $mode]} { return }
  220.     global win::Modes
  221.     changeMode $mode
  222.     if {[catch {win::Current} name]} return
  223.     set win::Modes($name) $mode
  224.     refresh
  225. }
  226.  
  227. # ◊◊◊◊ Mode specific items ◊◊◊◊ #
  228.  
  229. proc mode::menuProc {menu item} {
  230.     if {![llength [winNames]]} {
  231.         alertnote "No window!"
  232.         return
  233.     }
  234.     switch -- $item {
  235.         "preferences"       dialog::modifyModeFlags
  236.         "loadPrefsFile"     mode::sourcePrefsFile
  237.         "describeMode"      mode::describe
  238.         "changeMode"            mode::changeDialog
  239.     default {
  240.         mode::$item
  241.     }        
  242.     }
  243. }
  244.  
  245. ## 
  246.  # -------------------------------------------------------------------------
  247.  #     
  248.  # "win::setMode"    --
  249.  #    
  250.  #    Copes with endings like    '.orig'
  251.  #    or the backup ending '~' or ' copy', and checks a smart-mode line
  252.  #    like emacs, and handles a few Alpha-specific windows (trace dumps).
  253.  #
  254.  # -------------------------------------------------------------------------
  255.  ##
  256. proc win::setMode name {
  257.     global win::Modes
  258.     set win::Modes($name) [file::whichModeForWin $name]
  259. }
  260.  
  261.  
  262. ## 
  263.  # -------------------------------------------------------------------------
  264.  # 
  265.  # "win::addToMenu" --
  266.  # 
  267.  #  Adds a window name to the window menu.  This new version adds a 
  268.  #  binding, to work-around a bug in Alpha, so that using cmd-0-9
  269.  #  works if the window name contains square brackets.  The problem
  270.  #  is that the 'addMenuItem' line creates a binding of the form
  271.  #  'menu::winProc •263 namewith[square]brackets' which when evaluated
  272.  #  causes an error.  We force a separate binding to
  273.  #  'menu::winProc •263 {namewith[square]brackets}' which does work.
  274.  # -------------------------------------------------------------------------
  275.  ##
  276. proc win::addToMenu {name} {
  277.     global winNameToNum winMenu winNumToName
  278.     
  279.     for {set i 0} {$i<100} {incr i} {
  280.     if {![info exists winNumToName($i)]} {
  281.         regsub { <[0-9]+>$} $name {} nm
  282.         if {[file exists $nm]} {
  283.         set nm [file tail $name]
  284.         } else {
  285.         set nm $name
  286.         }
  287.         if {$i < 10} {
  288.         addMenuItem -m -l "/$i" $winMenu "$nm"
  289.         if {[info tclversion] < 8.0} {
  290.             Bind '$i' <c> [list menu::winProc $winMenu $nm]
  291.         }
  292.         } else {
  293.         addMenuItem -m -l "" $winMenu "$nm"
  294.         }
  295.         set winNumToName($i) $name
  296.         set winNameToNum($name) $i
  297.         return
  298.     }
  299.     }
  300. }
  301.  
  302. proc win::removeFromMenu {name} {
  303.     global winNameToNum winNumToName winMenu
  304.     if {[info tclversion] < 8.0} {
  305.     regsub -all {\\([][])} $name {\1} name
  306.     }
  307.     set num $winNameToNum($name)
  308.     unset winNumToName($num)
  309.     unset winNameToNum($name)
  310.     regsub { <[0-9]+>$} $name {} nm
  311.     if {[file exists $nm]} {
  312.     set nm [file tail $name]
  313.     } else {
  314.     # in case it was a file but the file was actually moved!
  315.     if {[regexp {[^:]*$} $name nm]} {
  316.         if {![catch {deleteMenuItem -m $winMenu $nm}]} { return } 
  317.     }
  318.     set nm $name
  319.     }
  320.     # to handle alpha problem with rebuilding the menu
  321.     if {[catch {deleteMenuItem -m $winMenu $nm}]} { deleteMenuItem $winMenu $nm }
  322. }
  323.  
  324. proc mode::changeDialog {} {
  325.     global mode mode::features
  326.  
  327.     set nmode [listpick -p "Mode:" -L $mode \
  328.       [lsort -ignore [array names mode::features]]]
  329.     newMode $nmode
  330. }
  331.  
  332. proc mode::describe {} {
  333.     global mode ModeSuffixes mode::features
  334.     global ${mode}modeVars
  335.     
  336.     set text "\r\tMODE $mode\r\r"
  337.     if {![catch {package::describe $mode 1} res]} {
  338.     append text $res "\r\r"
  339.     }
  340.  
  341.     set tmp ""
  342.     catch {set tmp [package::helpFile $mode 1]}
  343.     append text "$tmp\r\r"
  344.  
  345.     set suffs ""
  346.     set first 1
  347.     foreach suf $ModeSuffixes {
  348.         if {([llength $suf] == 3) && ([lindex $suf 1] == "winMode") \
  349.       && ([lindex $suf 2] == $mode)} {
  350.         if {$first} {
  351.         append suffs $last
  352.         set first 0
  353.         } else {
  354.                 append suffs ", $last"
  355.             }
  356.         }
  357.         set last $suf
  358.     }
  359.     append text "Mode filepats: " $suffs "\r\r"
  360.     
  361.     set first 1
  362.     append text "Mode menus and features: "
  363.     if {[info exists mode::features($mode)]} {
  364.         foreach m [set mode::features($mode)] {
  365.             if {$first} {
  366.                 set first 0
  367.                 append text $m
  368.             } else {
  369.                 append text ", " $m
  370.             }
  371.         }
  372.      }
  373.     append text "\r\r"
  374.     append text [mode::describeVars $mode]
  375.     
  376.     set etext "\rMode-independent bindings:\r"
  377.     append text "\rMode-specific bindings:\r"
  378.     foreach b [split [bindingList] "\r"] {
  379.     set lst [lindex [split $b  " "] end]
  380.         if {$lst == $mode} {
  381.             append text "\t$b\r"
  382.         }
  383.     }
  384.     append text "\rTo list mode-independent bindings, select\
  385.       'List Global/All Bindings'\rfrom the Config menu.\r"
  386.     new -n "* <$mode> MODE *" -m Tcl -text $text -shell 1 -read-only 1
  387. }
  388.  
  389. proc mode::describeVars {pkg {pkgpref ""}} {
  390.     cache::read index::prefshelp
  391.     if {$pkgpref == ""} {set pkgpref $pkg}
  392.     global ${pkgpref}modeVars
  393.     append text "Package-specific variables:\r"
  394.     if {[array exists ${pkgpref}modeVars]} {
  395.     foreach v [lsort [array names ${pkgpref}modeVars]] {
  396.         set val [set ${pkgpref}modeVars($v)]
  397.         global flag::type
  398.         set description ""
  399.         if {[info exists prefshelp(${pkg},$v)]} {
  400.         set description [dialog::helpdescription $prefshelp(${pkg},$v)]
  401.         } elseif {[info exists prefshelp(${pkgpref},$v)]} {
  402.         set description [dialog::helpdescription $prefshelp(${pkgpref},$v)]
  403.         } elseif {[info exists prefshelp($v)]} {
  404.         set description [dialog::helpdescription $prefshelp($v)]
  405.         }
  406.         
  407.         if {$description != ""} {
  408.         regsub -all "\[\r\n\]" [breakIntoLines $description] "&  \# " description
  409.         append text "  # " $description "\r"
  410.         }
  411.         if {[info exists flag::type($v)] \
  412.           && [regexp {binding$} [set flag::type($v)]]} {
  413.         set val [dialog::specialView_binding $val]
  414.         }
  415.         append text [format "  %-20s: \"%s\"\r" $v $val]
  416.     }
  417.     }
  418.     
  419.     return $text
  420. }
  421.  
  422. # Now calls the new proc dialog::pickMenus
  423. proc mode::menusAndFeatures {} {
  424.     global mode mode::features modifiedArrayElements global::features
  425.  
  426.     set newFeatures [dialog::pickMenusAndFeatures $mode]
  427.     set offon [package::onOrOff $newFeatures $mode]
  428.     
  429.     set mode::features($mode) $newFeatures
  430.     lappend modifiedArrayElements [list $mode mode::features]
  431.     # deactivate removed items
  432.     foreach m [lindex $offon 0] {
  433.     package::deactivate $m
  434.     }
  435.     foreach m [lindex $offon 1] {
  436.     package::activate $m
  437.     }
  438. }
  439.  
  440. if {[info tclversion] < 8.0} {
  441. proc mode::proc {name args} {
  442.     global mode
  443.     if {[info commands ${mode}::$name] != ""} {
  444.     eval ${mode}::$name $args
  445.     } else {
  446.     eval ::$name $args
  447.     }
  448. }
  449. proc mode::getProc {name} {
  450.     global mode
  451.     if {[info commands ${mode}::$name] != ""} {
  452.     return ${mode}::$name
  453.     } else {
  454.     return ""
  455.     }
  456. }
  457. proc mode::getVar {var} {
  458.     uplevel \#0 "
  459.     if \[info exists \${mode}::$var\] { 
  460.     return \[set \${mode}::$var\]
  461.     } else {
  462.     return \[set $var\]
  463.     } \
  464.       "
  465. }
  466.  
  467. } else {
  468.     proc mode::proc {name args} {
  469.     global ::mode
  470.     namespace eval ::$mode "$name $args"
  471.     }
  472.     proc mode::getProc {name} {
  473.     global ::mode
  474.     namespace eval ::$mode "namespace which $name"
  475.     }
  476.     proc mode::getVar {var} {
  477.     uplevel \#0 "
  478.     if \[info exists ::\${mode}::$var\] { 
  479.         return \[set ::\${mode}::$var\]
  480.     } else {
  481.         return \[set ::$var\]
  482.     } \
  483.       "
  484.     }
  485. }
  486.  
  487. # Suffixes used to determine mode for new windows.
  488. proc mode::updateSuffixes {} {
  489.     global ModeSuffixes mode::features filepats
  490.  
  491.     set ModeSuffixes { default { set winMode Text } }
  492.     foreach m [lsort -ignore [array names mode::features]] {
  493.         if {[info exists filepats($m)]} {
  494.         lappend ModeSuffixes $filepats($m) "set winMode $m"
  495.         }
  496.     }
  497. }
  498.  
  499. proc synchroniseModeVar {var args} {
  500.     global mode $var
  501.     if {[llength $args] > 0} {
  502.     set $var [lindex $args 0]
  503.     }
  504.     global ${mode}ModeVars modifiedArrayElements
  505.     lappend modifiedArrayElements [list $var ${mode}modeVars]
  506.     set ${mode}modeVars($var) [set $var]
  507. }
  508.  
  509. # ◊◊◊◊ Miscellaneous ◊◊◊◊ #
  510.  
  511. proc alpha::tryToLoad {msg args} {
  512.     message "${msg}…"
  513.     set i -1
  514.     set ok 1
  515.     while 1 {
  516.     set do [lindex $args [incr i]]
  517.     set say [lindex $args [incr i]]
  518.     if {$say == ""} {
  519.         set say "Loading $do"
  520.     }
  521.     if {$do == ""} {
  522.         if {$ok} {
  523.         message "${msg}…Complete."
  524.         } else {
  525.         alertnote "${msg}…Failed."
  526.         }
  527.         return $ok
  528.     }
  529.     message "${say}…"
  530.     if {[catch $do]} {
  531.         alertnote "$say failed!"
  532.     }
  533.     
  534.     }
  535. }
  536.  
  537. # ◊◊◊◊ Read in all the packages ◊◊◊◊ #
  538.  
  539. proc alpha::getBasicModes {} {
  540.     global PSwords
  541.     addMode PS {} {*.ps *.eps *.epsf} {}
  542.     newPref v prefixString {% } PS
  543.     set PSKeyWords {
  544.     def begin end dict load exec if ifelse for repeat loop exit 
  545.     stop stopped countexecstack execstack quit start gsave 
  546.     grestore grestoreall initgraphics newpath erasepage fill 
  547.     eofill stroke image imagemask showpage copypage
  548.     }
  549.     if {[info exists PSwords]} {set PSKeyWords [concat $PSKeyWords $PSwords]}
  550.     regModeKeywords -e {%} -m {/}  -c red -k blue PS $PSKeyWords -i "\}" -i "\{" -i {[} -i {]} -I green
  551.     
  552.     addMode Inst "" [list "*Install" "*INSTALL"] {installMenu}
  553.     addMenu installMenu "Install"
  554.     hook::register openHook install::openHook Inst
  555.     
  556.     addMode Text {} {default} {}
  557.     newPref v leftFillColumn {0} Text
  558.     newPref v suffixString { <--} Text
  559.     newPref v prefixString {> } Text
  560.     newPref v fillColumn {75} Text
  561.     newPref f wordWrap {1} Text
  562.     newPref v wordBreak {\w+} Text
  563.     newPref v wordBreakPreface {(\W)} Text
  564.     newPref v wrapBreak {[\w_]+} Text
  565.     newPref v wrapBreakPreface {([^\w_])} Text
  566.     newPref f autoMark 0 Text
  567.     newPref flag quietlyClearMarks 0 Text
  568.     namespace eval Text {}
  569.     proc Text::DblClick {args} {
  570.     eval Tcl::DblClick $args
  571.     }
  572. }
  573.  
  574. proc alpha::findAllPlugins {} {
  575.     alpha::findAllModes
  576.     global skipPrefs
  577.     if {!$skipPrefs} {
  578.     alpha::findAllExtensions
  579.     }
  580. }
  581.  
  582. proc alpha::findAllModes {} {
  583.     alpha::getBasicModes
  584.     rename alpha::getBasicModes {}
  585.     cache::read index::mode
  586.     foreach f [array names index::mode] {
  587.     eval addMode $f [lrange [set index::mode($f)] 1 3]
  588.     if {[set script [lindex [set index::mode($f)] 4]] != ""} {
  589.         if {[catch {uplevel #0 $script} err]} {
  590.         lappend problems "$f"
  591.         }
  592.     }
  593.     }
  594.     if {[info exists problems]} {
  595.     alertnote "Problems loading modes: $problems"
  596.     }
  597.     mode::updateSuffixes
  598. }
  599.  
  600.  
  601.  
  602.  
  603.